home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
TSPA3460
/
TSUNTG.TST
< prev
next >
Wrap
Text File
|
1994-08-16
|
6KB
|
251 lines
{$M 16384,0,655360}
(* This is a test program for the TSUNTG.TPU unit
Updated 26-Nov-89, 6-Dec-89, 14-Jun-90, 22-Jul-90, 1-Aug-90,
8-Aug-90, 27-Oct-91, 13-Jun-92, 19-Oct-92, 8-Nov-92,
26-Jul-93, 23-Jun-94 *)
uses Dos,
TSUNTB, (* to have access to number base conversion *)
TSUNTG
{$IFDEF VER40}
,TSUNT45
{$ENDIF}
;
procedure LOGO;
begin
writeln;
writeln ('TSUNTG unit test by Prof. Timo Salmi');
writeln ('University of Vaasa, Finland, ts@uwasa.fi');
{$IFDEF VER40}
writeln ('TP version 4.0');
{$ENDIF}
{$IFDEF VER50}
writeln ('TP version 5.0');
{$ENDIF}
{$IFDEF VER55}
writeln ('TP version 5.5');
{$ENDIF}
{$IFDEF VER60}
writeln ('TP version 6.0');
{$ENDIF}
{$IFDEF VER70}
writeln ('TP version 7.0');
{$ENDIF}
writeln;
end;
(* Number of diskette drives *)
procedure TEST1;
begin
writeln ('Number of diskette drives on this system is ', DRIVESFN);
end; (* test1 *)
(* Number of disk devices *)
procedure TEST2;
begin
{$IFDEF VER50}
if swap(DosVersion) < $0300 then
begin writeln ('Not MsDos 3.+'); exit; end;
{$ENDIF}
writeln ('Number of disks on this system is ', DSKCNTFN);
end; (* test2 *)
(* Number of diskette drives *)
procedure TEST3;
begin
writeln ('The first diskette drive is ', FDRIVEFN);
end; (* test3 *)
(* Is a media present in the drive *)
procedure TEST4;
const drive = 'B';
begin
If INDRIVFN (drive) then
writeln ('Disk present in drive ', drive)
else
writeln ('Disk not present in drive ', drive);
end; (* test4 *)
(* Cursor location test *)
procedure TEST5;
var x , y : byte;
begin
GOATXY (10, 20);
write ('▓The block is at 10,20 .');
x := WHEREXFN - 1; y := WHEREYFN;
write (' and the point at ', x:0, ',', y:0);
end; (* test5 *)
(* Reverse the colors of an area *)
procedure TEST6;
begin
REVAREA (2, 2, 79, 24);
GOATXY (1, 22);
end; (* test6 *)
(* Redirection of writes *)
procedure TEST7;
begin
writeln ('If you get runtime error 160, first test for printer readiness');
writeln ('TSUNTC has the relevant routines');
writeln;
USEPRN;
writeln ('This goes to the printer');
writeln ('As does this');
USECON;
write ('This goes on the screen');
end; (* test7 *)
(* Test whether a media is a fixed disk *)
procedure TEST8;
var drive : string;
begin
write ('Enter drive letter? '); readln (drive);
case Length (drive) of
0 : drive := '0';
else drive := UpCase(drive[1]);
end;
if FIXEDFN (drive[1]) then
writeln ('Media ', drive , ' is a fixed disk')
else
writeln ('Media ', drive , ' is not a fixed disk');
end; (* test8 *)
(* Test whether ANSI.SYS or a comparable driver has been loaded *)
procedure TEST9;
begin
if ISANSIFN then
writeln ('ANSI.SYS or a comparable screen driver has been installed')
else
begin
writeln;
writeln ('ANSI.SYS or a comparable screen driver has not been installed');
end;
end; (* test9 *)
(* Test the disk status *)
procedure TEST10;
const drive = 'A';
var status : integer;
begin
status := FLOPSTFN (drive);
if status = -1 then
begin
writeln ('Invalid drive, must be A or B');
exit;
end; {if}
writeln ('Disk status for ', drive, ': $', BHEXFN(status));
case status of
$00 : writeln ('Disk present');
$02 : writeln ('Address mark not found (Disk unformatted)');
$40 : writeln ('Seek failure (Disk not present?)');
$80 : writeln ('Disk timed out (Disk not present in drive)');
end;
end; (* test10 *)
(* Test whether a drive is a substituted drive *)
procedure TEST11;
const drive = 'R';
var isubst : boolean;
begin
if (100*Lo(DosVersion) + Hi(DosVersion)) < 310 then
begin
writeln ('The MsDos version must be at least 3.1');
exit;
end;
isubst := ISUBSTFN (drive);
writeln ('Drive ', drive, ' is a substituted drive is ', isubst);
end; (* test11 *)
(* What kind of a disk is in the drive *)
procedure TEST12;
const drive = 'B';
var mediaID : byte;
begin
mediaID := MEDIAFN (drive);
write ('Media currently in drive ', drive, ': is ');
case mediaID of
$00 : writeln ('Error');
$F0 : writeln ('Floppy of 1.44Mb');
$F8 : writeln ('Fixed disk');
$F9 : writeln ('Floppy of 1.2Mb');
$FA : writeln ('Floppy of 720Kb');
$FD : writeln ('Floppy of 360Kb');
$FF : writeln ('Floppy of 320Kb');
else writeln ('something else');
end; {case}
end; (* test12 *)
(* Get the currently active floppy drive on one drive systems *)
procedure TEST13;
var active : char;
begin
active := ACTDRVFN;
write ('The currently active floppy drive is ');
case active of
'0' : writeln ('Error ');
'A' : writeln ('A:');
'B' : writeln ('B:');
'2' : writeln ('not relevant (Two or more drives)');
end;
end; (* test13 *)
(* Test if a drive is a ram disk *)
procedure TEST14;
const drive = 'B';
var status : boolean;
begin
status := ISRAMFN (drive);
writeln ('Drive ', drive, ' is a ramdrive is ', status);
end; (* test14 *)
(* Is a drive a CD-ROM with MSCDEX driver installed *)
procedure TEST15;
var d : char;
begin
for d := 'A' to 'Z' do
write (' ', d, ': ', CDROMFN(d):5);
writeln;
end; (* test15 *)
procedure TEST16;
var d : char;
v : word;
begin
for d := 'A' to 'Z' do
if CDROMFN(d) then
begin
v := MSCVERFN (d);
writeln (d, ': version ', Hi(v), '.', Lo(v));
end;
end; (* test16 *)
(* Main program
If you just want a particular test, comment the others away, just as
I have done.
If you want pauses, put readln where appropriate *)
begin
LOGO;
TEST1;
TEST2;
TEST3;
TEST4;
TEST5;
TEST6;
TEST7;
TEST8;
TEST9;
TEST10;
TEST11;
TEST12;
TEST13;
TEST14;
TEST15;
TEST16;
{}
write ('Press <-'' '); readln;
end. (* tsuntg.tst *)